Usenet 1993 July

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / unix / volume26 / veos-2.0 / part05 < prev next >

Wrap

Text File | 1993-04-25 | 84.0 KB | 3,259 lines

Newsgroups: comp.sources.unix From: voodoo@hitl.washington.edu (Geoffery Coco) Subject: v26i188: veos-2.0 - The Virtual Environment Operating Shell, V2.0, Part05/16 Sender: unix-sources-moderator@vix.com Approved: paul@vix.com Submitted-By: voodoo@hitl.washington.edu (Geoffery Coco) Posting-Number: Volume 26, Issue 188 Archive-Name: veos-2.0/part05 #! /bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh <file", e.g.. If this archive is complete, you # will see the following message at the end: # "End of archive 5 (of 16)." # Contents: kernel_private/src/fern/fe_bnd.lsp # kernel_private/src/fern/fe_ext.lsp kernel_private/src/fern/fern.c # src/kernel_current/fern/fe_bnd.lsp # src/kernel_current/fern/fe_ext.lsp src/kernel_current/fern/fern.c # src/xlisp/xcore/c/xlimage.c # Wrapped by vixie@efficacy.home.vix.com on Sun Apr 25 23:10:36 1993 PATH=/bin:/usr/bin:/usr/ucb ; export PATH if test -f 'kernel_private/src/fern/fe_bnd.lsp' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'kernel_private/src/fern/fe_bnd.lsp'\" else echo shar: Extracting \"'kernel_private/src/fern/fe_bnd.lsp'\" $10935 characters$ sed "s/^X//" >'kernel_private/src/fern/fe_bnd.lsp' <<'END_OF_FILE' X;;----------------------------------------------------------- X;; file: fe_bnd.lsp X;; X;; FERN is the Fractal Entity Relativity Node. X;; Part of the FE component of the Fern System. X;; X;; creation: March 28, 1992 X;; X;; by Geoffrey P. Coco at the HITLab, Seattle X;;----------------------------------------------------------- X X X;;----------------------------------------------------------- X;; Copyright (C) 1992 Geoffrey P. Coco, X;; Human Interface Technology Lab, Seattle X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Boundary X;;=========================================================== X X(defun fe-put.bndry (bndry) X (vput bndry '((~ "perc" X @ X > @ X @) **))) X X;;----------------------------------------------------------- X X(defun fe-copy.bndry (&key (test-time nil)) X (car (vcopy '(("perc" X @ X > @ X @) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.bndry () X (vget '(("perc" X @ X (> @@) X @) **))) X X;;----------------------------------------------------------- X X(defun fe-get.bndry () X (car (vput "%" '((~ "perc" X @ X > @ X @) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Virtual X;;=========================================================== X X;; returns old virtual bndry X(defun fe-put.bndry.vrt (vbndry) X (car (vput vbndry '((~ "perc" X @ X (@ > @ @) X @) **)))) X X;;----------------------------------------------------------- X X;; cache this frequently used pattern in C level fern. X;; later, calls to fe-copy.bndry.vrt use precomputed pattern. X X(fbase-init-copy.bndry.vrt '(("perc" X @ X (@ > @ @) X @) **)) X X#| X(defun fe-copy.bndry.vrt (&key (test-time nil)) X (car (vcopy '(("perc" X @ X (@ > @ @) X @) **) X :test-time test-time))) X|# X;;----------------------------------------------------------- X X(defun fe-xtrct.bndry.vrt () X (vget '(("perc" X @ X (@ (> @@) @) X @) **))) X X;;----------------------------------------------------------- X X(defun fe-get.bndry.vrt () X (car (vput "%" '(("perc" X @ X (@ > @ @) X @) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Virtual Objects X;;=========================================================== X X(defun fe-jam.bndry.vrt.ob (ob) X (vput ob '((~ "perc" X @ X (@ (^ @@) @) X @) **))) X X;;----------------------------------------------------------- X X;; objects are (ob-name (attr-list)) X(defun fe-put.bndry.vrt.ob (ob) X (cond X X ;; assume object is already there X ((car (vput ob `((~ "perc" X @ X (@ (> (,(car ob) @) **) @) X @) **)))) X X ;; object wasn't there, insert new one X ((fe-jam.bndry.vrt.ob ob)) X )) X X;;----------------------------------------------------------- X X;; pass object name X(defun fe-copy.bndry.vrt.ob (ob-name &key (test-time nil)) X (car (vcopy `(("perc" X @ X (@ (> (,ob-name @) **) @) X @) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.bndry.vrt.ob (ob-name) X (car (vget `(("perc" X @ X (@ (> (,ob-name @) **) @) X @) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.bndry.vrt.ob (ob-name) X (car (vput "%" `((~ "perc" X @ X (@ ((~ ,ob-name > @) **) @) X @) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Virtual Object - Complex X;;=========================================================== X X(defun fe-copy.bndry.vrt.ob.names () X (vcopy `(("perc" X @ X (@ ((> @ @) **) @) X @) **) X :freq "all")) X X;;----------------------------------------------------------- X X X X X;;=========================================================== X;; Virtual Object Attributes X;;=========================================================== X X(defun fe-jam.bndry.vrt.ob.attr (ob-name attr) X (cond X ;; assume object exists, add new attr X ((vput attr `((~ "perc" X @ X (@ ((~ ,ob-name (^ @@)) **) @) X @) **))) X X ;; object didn't exist, add new object with new attr. X ((fe-jam.bndry.vrt.ob `(,ob-name (,attr)))) X )) X X;;----------------------------------------------------------- X X(defun fe-put.bndry.vrt.ob.attr (ob-name attr) X (cond X X ;; assume the object and attr exist, swap in new attr X ((car (vput attr `((~ "perc" X @ X (@ ((~ ,ob-name (> (,(car attr) @) **)) **) @) X @) **)))) X X ;; attr didn't exist, add new attr X ((fe-jam.bndry.vrt.ob.attr ob-name attr)) X )) X X;;----------------------------------------------------------- X X(defun fe-xtrct.bndry.vrt.ob.attr (ob-name attr-name) X (car (vget `(("perc" X @ X (@ ((,ob-name (> (,attr-name @) **)) **) @) X @) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.bndry.vrt.ob.attr (ob-name attr-name) X (car (vput "%" `((~ "perc" X @ X (@ ((~ ,ob-name ((~ ,attr-name > @) **)) **) @) X @) **)))) X X;;----------------------------------------------------------- X X;; returns attr struct X(defun fe-copy.bndry.vrt.ob.attr (ob-name attr-name &key (test-time nil)) X (car (vcopy `(("perc" X @ X (@ ((,ob-name (> (,attr-name @) **)) **) @) X @) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Virtual Object Attributes - Complex X;;=========================================================== X X;; returns list of boundary attribute names X(defun fe-copy.bndry.vrt.ob.attr.names (ob-name) X (vcopy `(("perc" X @ X (@ ((,ob-name ((> @ @) **)) **) @) X @) **) X :freq "all")) X X;;----------------------------------------------------------- X X;; returns attr val X(defun fe-copy.bndry.vrt.ob.attr.val (ob-name attr-name) X (car (vcopy `(("perc" X @ X (@ ((,ob-name ((,attr-name > @) **)) **) @) X @) **)))) X X;;----------------------------------------------------------- X X X X X;;=========================================================== X;; Physical Sub-Partition X;;=========================================================== X X;; returns old physical bndry X(defun fe-put.bndry.phys (vbndry) X (car (vput vbndry '((~ "perc" X @ X (@2 > @) X @) **)))) X X;;----------------------------------------------------------- X X(defun fe-copy.bndry.phys (&key (test-time nil)) X (car (vcopy '(("perc" X @ X (@2 > @) X @) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.bndry.phys () X (vget '(("perc" X @ X (@2 (> @@)) X @) **))) X X;;----------------------------------------------------------- X X(defun fe-get.bndry.phys () X (car (vput "%" '((~ "perc" X @ X (@2 > @) X @) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Physical Objects X;;=========================================================== X X(defun fe-jam.bndry.phys.ob (ob) X (vput ob '((~ "perc" X @ X (@2 (^ @@)) X @) **))) X X;;----------------------------------------------------------- X X;; objects are (ob-name (attr-list)) X(defun fe-put.bndry.phys.ob (ob) X (cond X X ;; assume object is already there X ((car (vput ob `((~ "perc" X @ X (@2 (> (,(car ob) @) **)) X @) **)))) X X ;; object wasn't there, insert new one X ((fe-jam.bndry.phys.ob ob)) X )) X X;;----------------------------------------------------------- X X;; pass object name X(defun fe-copy.bndry.phys.ob (ob-name &key (test-time nil)) X (car (vcopy `(("perc" X @ X (@2 (> (,ob-name @) **)) X @) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.bndry.phys.ob (ob-name) X (car (vget `(("perc" X @ X (@2 (> (,ob-name @) **)) X @) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.bndry.phys.ob (ob-name) X (car (vput "%" `((~ "perc" X @ X (@2 ((~ ,ob-name > @) **)) X @) **)))) X X;;----------------------------------------------------------- X X X X X;;=========================================================== X;; Physical Object - Complex X;;=========================================================== X X(defun fe-copy.bndry.phys.ob.names () X (vcopy `(("perc" X @ X (@2 ((> @ @) **)) X @) **) X :freq "all")) X X;;----------------------------------------------------------- X X X X X;;=========================================================== X;; Physical Object Attributes X;;=========================================================== X X(defun fe-jam.bndry.phys.ob.attr (ob-name attr) X (cond X ;; assume object exists, add new attr X ((vput attr `((~ "perc" X @ X (@2 ((~ ,ob-name (^ @@)) **)) X @) **))) X X ;; object didn't exist, add new object with new attr. X ((fe-jam.bndry.phys.ob `(,ob-name (,attr)))) X )) X X;;----------------------------------------------------------- X X(defun fe-put.bndry.phys.ob.attr (ob-name attr) X (cond X X ;; assume the object and attr exist, swap in new attr X ((car (vput attr `((~ "perc" X @ X (@2 ((~ ,ob-name (> (,(car attr) @) **)) **)) X @) **)))) X X ;; attr didn't exist, add new attr X ((fe-jam.bndry.phys.ob.attr ob-name attr)) X )) X X;;----------------------------------------------------------- X X(defun fe-xtrct.bndry.phys.ob.attr (ob-name attr-name) X (car (vget `(("perc" X @ X (@2 ((,ob-name (> (,attr-name @) **)) **)) X @) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.bndry.phys.ob.attr (ob-name attr-name) X (car (vput "%" `((~ "perc" X @ X (@2 ((~ ,ob-name ((~ ,attr-name > @) **)) **)) X @) **)))) X X;;----------------------------------------------------------- X X;; returns attr struct X(defun fe-copy.bndry.phys.ob.attr (ob-name attr-name &key (test-time nil)) X (car (vcopy `(("perc" X @ X (@2 ((,ob-name (> (,attr-name @) **)) **)) X @) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Physical Object Attributes - Complex X;;=========================================================== X X;; returns list of boundary attribute names X(defun fe-copy.bndry.phys.ob.attr.names (ob-name) X (vcopy `(("perc" X @ X (@2 ((,ob-name ((> @ @) **)) **)) X @) **) X :freq "all")) X X;;----------------------------------------------------------- X X;; returns attr val X(defun fe-copy.bndry.phys.ob.attr.val (ob-name attr-name) X (car (vcopy `(("perc" X @ X (@2 ((,ob-name ((,attr-name > @) **)) **)) X @) **)))) X X;;----------------------------------------------------------- X X X X END_OF_FILE if test 10935 -ne `wc -c <'kernel_private/src/fern/fe_bnd.lsp'`; then echo shar: \"'kernel_private/src/fern/fe_bnd.lsp'\" unpacked with wrong size! fi # end of 'kernel_private/src/fern/fe_bnd.lsp' fi if test -f 'kernel_private/src/fern/fe_ext.lsp' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'kernel_private/src/fern/fe_ext.lsp'\" else echo shar: Extracting \"'kernel_private/src/fern/fe_ext.lsp'\" $11360 characters$ sed "s/^X//" >'kernel_private/src/fern/fe_ext.lsp' <<'END_OF_FILE' X;;----------------------------------------------------------- X;; file: fe_ext.lsp X;; X;; FERN is the Fractal Entity Relativity Node. X;; Part of the FE component of the Fern System. X;; X;; creation: March 28, 1992 X;; X;; by Geoffrey P. Coco at the HITLab, Seattle X;;----------------------------------------------------------- X X X;;----------------------------------------------------------- X;; Copyright (C) 1992 Geoffrey P. Coco, X;; Human Interface Technology Lab, Seattle X;;----------------------------------------------------------- X X X;;=========================================================== X;; External X;;=========================================================== X X(defun fe-put.ext (ext) X (vput ext '((~ "perc" X > @ X @ X @) **))) X X;;----------------------------------------------------------- X X(defun fe-copy.ext (&key (test-time nil)) X (car (vcopy '(("perc" X > @ X @ X @) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.ext () X (vget '(("perc" X (> @@) X @ X @) **))) X X;;----------------------------------------------------------- X X(defun fe-get.ext () X (car (vput "%" '((~ "perc" X > @ X @ X @) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Spaces Sub-Partition X;;=========================================================== X X;; returns old space-list X(defun fe-put.ext.sps (sps) X (car (vput sps '((~ "perc" X (> @ @2) X @2) **)))) X X;;----------------------------------------------------------- X X(defun fe-copy.ext.sps (&key (test-time nil)) X (car (vcopy '(("perc" X (> @ @2) X @2) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.ext.sps () X (vget '(("perc" X ((> @@) @2) X @2) **))) X X;;----------------------------------------------------------- X X(defun fe-get.ext.sps () X (car (vput "%" '((~ "perc" X (> @ @2) X @2) **)))) X X;;----------------------------------------------------------- X X X;;=========================================================== X;; Spaces Entities X;;=========================================================== X X;; an ent is (uid data) X(defun fe-jam.ext.sps.ent (ent) X (vput ent '((~ "perc" X ((^ @@) @2) X @2) **))) X X;;----------------------------------------------------------- X X;; an ent is (uid data) X(defun fe-put.ext.sps.ent (ent) X (cond X ;; assume the entity already exists, swap in new one X ((car (vput ent `((~ "perc" X ((> (,(car ent) @) **) @2) X @2) **)))) X X ;; entity didn' exist, insert new ent X ((fe-jam.ext.sps.ent ent)))) X X;;----------------------------------------------------------- X X(defun fe-copy.ext.sps.ent (uid &key (test-time nil)) X (car (vcopy `(("perc" X ((> (,uid @) **) @2) X @2) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.ext.sps.ent (uid) X (car (vget `(("perc" X ((> (,uid @) **) @2) X @2) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.ext.sps.ent (uid) X (car (vput "%" `((~ "perc" X (((~ ,uid > @) **) @2) X @2) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Siblings Sub-Partition X;;=========================================================== X X;; returns old sib-list X(defun fe-put.ext.sibs (sibs) X (car (vput sibs '((~ "perc" X (@ > @ @) X @2) **)))) X X;;----------------------------------------------------------- X X(defun fe-copy.ext.sibs (&key (test-time nil)) X (car (vcopy '(("perc" X (@ > @ @) X @2) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.ext.sibs () X (vget '(("perc" X (@ (> @@) @) X @2) **))) X X;;----------------------------------------------------------- X X(defun fe-get.ext.sibs () X (car (vput "%" '((~ "perc" X (@ > @ @) X @2) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Siblings Entities X;;=========================================================== X X(defun fe-jam.ext.sibs.ent (ent) X (vput ent '((~ "perc" X (@ (^ @@) @) X @2) **))) X X;;----------------------------------------------------------- X X;; sibling entities are in the form: (uid (virtual object list)) X(defun fe-put.ext.sibs.ent (ent) X (cond X ;; assume the ent exists, swap in new ent X ((car (vput ent `((~ "perc" X (@ (> (,(car ent) @) **) @) X @2) **)))) X ;; the ent didn't exist, add new ent X ((fe-jam.ext.sibs.ent ent)) X )) X X;;----------------------------------------------------------- X X(defun fe-copy.ext.sibs.ent (uid &key (test-time nil)) X (car (vcopy `(("perc" X (@ (> (,uid @) **) @) X @2) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.ext.ents.ent (uid) X (car (vget `(("perc" X (@ (> (,uid @) **) @) X @2) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.ext.ents.ent (uid) X (car (vput "%" `((~ "perc" X (@ ((~ ,uid > @) **) @) X @2) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Siblings Entities - Complex X;;=========================================================== X X;; returns list of all external sibs' uids X(defun fe-copy.ext.sibs.uids () X (vcopy '(("perc" X (@ ((> @ @) **) @) X @2) **) X :freq "all")) X X;;----------------------------------------------------------- X X X X X;;=========================================================== X;; Sibling Entities Objects X;;=========================================================== X X(defun fe-jam.ext.sibs.ent.ob (uid ob) X (cond X X ;; assume entity exists, insert new object X ((vput ob `((~ "perc" X (@ ((~ ,uid (^ @@)) **) @) X @2) **))) X X ;; entity wasn't there, insert new entity with new object X ((fe-jam.ext.sibs.ent `(,uid (,ob)))) X )) X X;;----------------------------------------------------------- X X;; ob is a normal object structure: (name (attr-list)) X(defun fe-put.ext.sibs.ent.ob (uid ob) X (cond X X ;; assume entity and object exist, swap in new object X ((car (vput ob `((~ "perc" X (@ ((~ ,uid (> (,(car ob) @) **)) **) @) X @2) **)))) X X ;; object wasn't there, assume entity exists, insert new object X ((fe-jam.ext.sibs.ent.ob uid ob)) X )) X X;;----------------------------------------------------------- X X(defun fe-copy.ext.sibs.ent.ob (uid ob-name &key (test-time nil)) X (car (vcopy `(("perc" X (@ ((,uid (> (,ob-name @) **)) **) @) X @2) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.ext.sibs.ent.ob (uid ob-name) X (car (vget `(("perc" X (@ ((,uid (> (,ob-name @) **)) **) @) X @2) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.ext.sibs.ent.ob (uid ob-name) X (car (vput "%" `((~ "perc" X (@ ((~ ,uid ((~ ,ob-name > @) **)) **) @) X @2) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Sibling Entities Objects - Complex X;;=========================================================== X X;; pass uid, get list of it's ob names X(defun fe-copy.ext.sibs.ent.ob.names (uid) X (vcopy `(("perc" X (@ ((,uid ((> @ @) **)) **) @) X @2) **) X :freq "all")) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Sibling Entities Objects Attributes X;;=========================================================== X X X(defun fe-jam.ext.sibs.ent.ob.attr (uid ob-name attr) X (cond X ;; assume entity and ob exists, insert new attr X ((vput attr `((~ "perc" X (@ X ((~ ,uid ((~ ,ob-name (^ @@)) **)) **) X @) X @2) **))) X X ;; ob wasn't there, insert new ob with new attr X ((fe-jam.ext.sibs.ent.ob uid `(,ob-name (,attr)))) X )) X X;;----------------------------------------------------------- X X;; attr is ("attr-name" attr-val) X(defun fe-put.ext.sibs.ent.ob.attr (uid ob-name attr) X (cond X ;; assume the ent, ob and attr exist, swap in new attr X ((car (vput attr `((~ "perc" X (@ X ((~ ,uid ((~ ,ob-name (> (,(car attr) @) **)) **)) **) X @) X @2) **)))) X X ;; attr wasn't there, insert new attr X ((fe-jam.ext.sibs.ent.ob.attr uid ob-name attr)) X )) X X;;----------------------------------------------------------- X X;; pass uid, ob-num, attr-name X(defun fe-copy.ext.sibs.ent.ob.attr (uid ob-num attr-name &key (test-time nil)) X (car (vcopy `(("perc" X (@ X ((,uid ((,ob-num (> (,attr-name @) **)) **)) **) X @) X @2) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X;; pass uid, ob-num, attr-name X(defun fe-xtrct.ext.sibs.ent.ob.attr (uid ob-num attr-name) X (car (vget `(("perc" X (@ X ((,uid ((,ob-num (> (,attr-name @) **)) **)) **) X @) X @2) **)))) X X;;----------------------------------------------------------- X X;; pass uid, ob-num, attr-name X(defun fe-get.ext.sibs.ent.ob.attr (uid ob-num attr-name) X (car (vput "%" `((~ "perc" X (@ X ((~ ,uid ((~ ,ob-num ((~ ,attr-name > @) **)) **)) **) X @) X @2) **)))) X X;;----------------------------------------------------------- X X X;;=========================================================== X;; Sibling Entities Objects Attributes - Complex X;;=========================================================== X X;; pass uid and ob, return attr-list X(defun fe-copy.ext.sibs.ent.ob.attr.names (uid ob-name) X (vcopy `(("perc" X (@ X ((,uid ((,ob-name ((> @ @) **)) **)) **) X @) X @2) **) X :freq "all")) X X;;----------------------------------------------------------- X X;; pass attr, return values of all objects of all sibs X(defun fe-copy.ext.sibs.attr.vals (attr-name) X (vcopy `(("perc" X (@ X ((@ ((@ ((,attr-name > @) **)) **)) **) X @) X @2) **) X :freq "all")) X X;;----------------------------------------------------------- X X;; pass uid, ob-num, attr-name X(defun fe-copy.ext.sibs.ent.ob.attr.val (uid ob-num attr-name) X (car (vcopy `(("perc" X (@ X ((,uid ((,ob-num ((,attr-name > @) **)) **)) **) X @) X @2) **)))) X X;;----------------------------------------------------------- X X X X X;;=========================================================== X;; Filters Sub-Partition X;;=========================================================== X X;; filters are ("attr" (inclusion-list)) X(defun fe-put.ext.fltrs (fltrs) X (vput fltrs '((~ "perc" X (@2 > @) X @2) **))) X X;;----------------------------------------------------------- X X(defun fe-copy.ext.fltrs (&key (test-time nil)) X (car (vcopy '(("perc" X (@2 > @) X @2) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.ext.fltrs () X (vget '(("perc" X (@2 (> @@)) X @2) **))) X X;;----------------------------------------------------------- X X(defun fe-get.ext.fltrs () X (car (vput "%" '((~ "perc" X (@2 > @) X @2) **)))) X X;;----------------------------------------------------------- END_OF_FILE if test 11360 -ne `wc -c <'kernel_private/src/fern/fe_ext.lsp'`; then echo shar: \"'kernel_private/src/fern/fe_ext.lsp'\" unpacked with wrong size! fi # end of 'kernel_private/src/fern/fe_ext.lsp' fi if test -f 'kernel_private/src/fern/fern.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'kernel_private/src/fern/fern.c'\" else echo shar: Extracting \"'kernel_private/src/fern/fern.c'\" $11012 characters$ sed "s/^X//" >'kernel_private/src/fern/fern.c' <<'END_OF_FILE' X/**************************************************************************************** X * file: fern.c * X * * X * February 25, 1992: implementation of the Fractal Entity Relativity Node for veos. * X * * X * by Geoffrey P. Coco at the HITLab, Seattle. * X * * X ****************************************************************************************/ X X/**************************************************************************************** X * Copyright (C) 1992 Human Interface Technology Lab, Seattle * X ****************************************************************************************/ X X X/*--------------------------------------------------------------------------------* X Preliminaries X *--------------------------------------------------------------------------------*/ X X X#include "xlisp.h" X#include "kernel.h" X#include "xv_native.h" X#include "fern.h" X X#include <math.h> X X/*--------------------------------------------------------------------------------*/ X Xboolean fbase_bInit = FALSE; Xboolean fbase_bGoing = FALSE; XLVAL s_pPersistFunc, s_pPersistProcs; XTStampEntHash fbase_pHashes[5]; Xint fbase_iHashFree; XTXMandRRec fbase_pbCopyIntSubs; XTXMandRRec fbase_pbCopyBndryVrt; X X/*--------------------------------------------------------------------------------*/ X Xvoid Fbase_Frame(); XTVeosErr Fbase_InitMatcherPBs(); X X/*--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------* X Lisp Interface To Fern X *--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ XLVAL Fbase_Init() X{ X if (!fbase_bInit) { X X /** make permanent xlisp symbol to contain persist function call **/ X X s_pPersistFunc = xlenter("FC-PRS-NTRY"); X setvalue(s_pPersistFunc, cons(xlenter("FCON-PERSIST"), NIL)); X X s_pPersistProcs = xlenter("PERSIST-PROCS"); X X fbase_iHashFree = 0; X X Fbase_InitMatcherPBs(); X } X X return(true); X } X/*--------------------------------------------------------------------------------*/ X X X X/*--------------------------------------------------------------------------------*/ XLVAL Fbase_fcon_time() X{ X xllastarg(); X X Fbase_Frame(); X X return(true); X } X/*--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ XLVAL Fbase_fcon_go() X{ X xllastarg(); X X fbase_bGoing = TRUE; X while (fbase_bGoing) X Fbase_Frame(); X X return(true); X } X/*--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ XLVAL Fbase_fcon_local_ungo() X{ X xllastarg(); X X fbase_bGoing = FALSE; X X return(true); X } X/*--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ X/* returns: hash-table-index of new fern maintained hash table X */ XLVAL Fbase_Hash_NewTab() X{ X int i, iHashTab; X X iHashTab = fbase_iHashFree++; X for (i=0; i<12; i++) X fbase_pHashes[iHashTab][i] = nil; X X return(cvfixnum(iHashTab)); X } X/*--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ X/* args: hash-table-refnum, new-uid, initial-float-data X */ XLVAL Fbase_Hash_AddUid() X{ X LVAL pReturn = NIL, pUid; X int i, iHashTab, iHashIndex; X float fData; X TPStampEntRec pNode, pFinger; X X iHashTab = getfixnum(xlgafixnum()); X X pUid = xlgavector(); X#ifndef OPTIMAL X if (!IsUidElt(pUid)) X xlbadtype(pUid); X#endif X X fData = getflonum(xlgaflonum()); X X iHashIndex = FBASE_HASH_HOST(getstring(getelement(pUid, 0))); X X X /** check for this uid already in table... X ** if so, just update data X **/ X for (pNode = fbase_pHashes[iHashTab][iHashIndex]; X pNode; X pNode = pNode->pNext) { X X if (FBASE_HASH_HIT(pUid, pNode)) { X pNode->fData = fData; X pReturn = true; X break; X } X } X X /** uid not found, add new hash entry. X **/ X if (pReturn == NIL) { X X if (Shell_NewBlock(sizeof(TStampEntRec), X &pNode, "fern-hash-node") == VEOS_SUCCESS) { X X strcpy(pNode->sHost, getstring(getelement(pUid, 0))); X pNode->iPort = getfixnum(getelement(pUid, 1)); X pNode->fData = fData; X X pNode->pNext = fbase_pHashes[iHashTab][iHashIndex]; X fbase_pHashes[iHashTab][iHashIndex] = pNode; X X pReturn = true; X } X } X X return(pReturn); X } X/*--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ X/* args: hash-table-index, uid X */ XLVAL Fbase_Hash_RemoveUid() X{ X LVAL pReturn = NIL, pUid; X int i, iHashTab, iHashIndex; X THStampEntRec hFinger; X TPStampEntRec pSave; X X iHashTab = getfixnum(xlgafixnum()); X X pUid = xlgavector(); X if (!IsUidElt(pUid)) X xlbadtype(pUid); X X iHashIndex = FBASE_HASH_HOST(getstring(getelement(pUid, 0))); X for (hFinger = &(fbase_pHashes[iHashTab][iHashIndex]); X *hFinger; X hFinger = &(*hFinger)->pNext) { X X if (FBASE_HASH_HIT(pUid, *hFinger)) { X pSave = *hFinger; X *hFinger = pSave->pNext; X Shell_ReturnBlock(pSave, sizeof(TStampEntRec), "fern-hash-node"); X pReturn = true; X break; X } X } X X return(pReturn); X } X/*--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ X/* args: hash-table-index, uid, float-to-place-data. X * returns: true or NIL X */ XLVAL Fbase_Hash_HashUid() X{ X LVAL pReturn = NIL, pUid, pData; X int i, iHashTab, iHashIndex; X TPStampEntRec pFinger; X X iHashTab = getfixnum(xlgafixnum()); X X pUid = xlgavector(); X if (!IsUidElt(pUid)) X xlbadtype(pUid); X X pData = xlgaflonum(); X X iHashIndex = FBASE_HASH_HOST(getstring(getelement(pUid, 0))); X for (pFinger = fbase_pHashes[iHashTab][iHashIndex]; X pFinger; X pFinger = pFinger->pNext) { X X if (FBASE_HASH_HIT(pUid, pFinger)) { X setflonum(pData, pFinger->fData); X pReturn = true; X break; X } X } X X return(pReturn); X } X/*--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ XLVAL Fbase_Init_CopyIntSubs() X{ X TVeosErr iErr; X X iErr = Native_GetPatternArg(&fbase_pbCopyIntSubs.pPatGr, NANCY_CopyMatch); X X return(iErr == VEOS_SUCCESS ? true : NIL); X } X/*--------------------------------------------------------------------------------*/ X X X X/*--------------------------------------------------------------------------------*/ XLVAL Fbase_CopyIntSubs() X{ X TVeosErr iErr; X LVAL pReturn; X TTimeStamp tTest; X X X /** look for optional time-stamp-test **/ X X NATIVE_TIME_ARG(fbase_pbCopyIntSubs.pTestTime, tTest); X X X /** dispatch the matcher **/ X X xlsave1(fbase_pbCopyIntSubs.pXResult); X X Native_XMandR(&fbase_pbCopyIntSubs); X X xlpop(); X X pReturn = consp(fbase_pbCopyIntSubs.pXResult) ? X car(fbase_pbCopyIntSubs.pXResult) : fbase_pbCopyIntSubs.pXResult; X X return(pReturn); X } X/*--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ XLVAL Fbase_Init_CopyBndryVrt() X{ X TVeosErr iErr; X X iErr = Native_GetPatternArg(&fbase_pbCopyBndryVrt.pPatGr, NANCY_CopyMatch); X X return(iErr == VEOS_SUCCESS ? true : NIL); X } X/*--------------------------------------------------------------------------------*/ X X X X/*--------------------------------------------------------------------------------*/ XLVAL Fbase_CopyBndryVrt() X{ X TVeosErr iErr; X LVAL pReturn; X TTimeStamp tTest; X X X /** look for optional time-stamp-test **/ X X NATIVE_TIME_ARG(fbase_pbCopyBndryVrt.pTestTime, tTest); X X X /** dispatch the matcher **/ X X xlsave1(fbase_pbCopyBndryVrt.pXResult); X X Native_XMandR(&fbase_pbCopyBndryVrt); X X xlpop(); X X pReturn = consp(fbase_pbCopyBndryVrt.pXResult) ? X car(fbase_pbCopyBndryVrt.pXResult) : fbase_pbCopyBndryVrt.pXResult; X X return(pReturn); X } X/*--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------* X Beuratrcatic Linkage Between Fern Prims and XLISP X *--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ XTVeosErr Fern_LoadPrims() X{ X#define FERN_LOAD X#include "fern_prims.h" X#define FERN_LOAD X } X/*--------------------------------------------------------------------------------*/ X X X X/*--------------------------------------------------------------------------------* X Private Functions X *--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ XTVeosErr Fbase_() X{ X TVeosErr iErr; X X return(iErr); X } X/*--------------------------------------------------------------------------------*/ X X X X/*--------------------------------------------------------------------------------*/ Xvoid Fbase_Frame() X{ X LVAL pMsg; X X X /** pass time to veos kernel for accounting. X **/ X Kernel_SystemTask(); X X X for (Native_NextMsg(&pMsg); X pMsg; X Native_NextMsg(&pMsg)) { X X /** invoke normal lisp evaluator on message. X **/ X xlxeval(pMsg); X X /** at top of loop, when msgVar is set to next msg, X ** old contents of msgVar are detached from any protected xlisp ptr, X ** thus it will be garbage collected. X **/ X } X X /** do the persist procs. X **/ X if (!null(getvalue(s_pPersistProcs))) X xleval(getvalue(s_pPersistFunc)); X } X/*--------------------------------------------------------------------------------*/ X X X X/*--------------------------------------------------------------------------------*/ XTVeosErr Fbase_InitMatcherPBs() X{ X /** copy-int-subs settings **/ X X fbase_pbCopyIntSubs.pSrcGr = WORK_SPACE; X fbase_pbCopyIntSubs.iDestroyFlag = NANCY_CopyMatch; X fbase_pbCopyIntSubs.pXReplaceElt = nil; X fbase_pbCopyIntSubs.pStampTime = nil; X X /** copy-bndry-vrt settings **/ X X fbase_pbCopyBndryVrt.pSrcGr = WORK_SPACE; X fbase_pbCopyBndryVrt.iDestroyFlag = NANCY_CopyMatch; X fbase_pbCopyBndryVrt.pXReplaceElt = nil; X fbase_pbCopyBndryVrt.pStampTime = nil; X X return(VEOS_SUCCESS); X X } /* Fbase_InitMatcherPBs */ X/*--------------------------------------------------------------------------------*/ X X X END_OF_FILE if test 11012 -ne `wc -c <'kernel_private/src/fern/fern.c'`; then echo shar: \"'kernel_private/src/fern/fern.c'\" unpacked with wrong size! fi # end of 'kernel_private/src/fern/fern.c' fi if test -f 'src/kernel_current/fern/fe_bnd.lsp' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'src/kernel_current/fern/fe_bnd.lsp'\" else echo shar: Extracting \"'src/kernel_current/fern/fe_bnd.lsp'\" $10935 characters$ sed "s/^X//" >'src/kernel_current/fern/fe_bnd.lsp' <<'END_OF_FILE' X;;----------------------------------------------------------- X;; file: fe_bnd.lsp X;; X;; FERN is the Fractal Entity Relativity Node. X;; Part of the FE component of the Fern System. X;; X;; creation: March 28, 1992 X;; X;; by Geoffrey P. Coco at the HITLab, Seattle X;;----------------------------------------------------------- X X X;;----------------------------------------------------------- X;; Copyright (C) 1992 Geoffrey P. Coco, X;; Human Interface Technology Lab, Seattle X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Boundary X;;=========================================================== X X(defun fe-put.bndry (bndry) X (vput bndry '((~ "perc" X @ X > @ X @) **))) X X;;----------------------------------------------------------- X X(defun fe-copy.bndry (&key (test-time nil)) X (car (vcopy '(("perc" X @ X > @ X @) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.bndry () X (vget '(("perc" X @ X (> @@) X @) **))) X X;;----------------------------------------------------------- X X(defun fe-get.bndry () X (car (vput "%" '((~ "perc" X @ X > @ X @) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Virtual X;;=========================================================== X X;; returns old virtual bndry X(defun fe-put.bndry.vrt (vbndry) X (car (vput vbndry '((~ "perc" X @ X (@ > @ @) X @) **)))) X X;;----------------------------------------------------------- X X;; cache this frequently used pattern in C level fern. X;; later, calls to fe-copy.bndry.vrt use precomputed pattern. X X(fbase-init-copy.bndry.vrt '(("perc" X @ X (@ > @ @) X @) **)) X X#| X(defun fe-copy.bndry.vrt (&key (test-time nil)) X (car (vcopy '(("perc" X @ X (@ > @ @) X @) **) X :test-time test-time))) X|# X;;----------------------------------------------------------- X X(defun fe-xtrct.bndry.vrt () X (vget '(("perc" X @ X (@ (> @@) @) X @) **))) X X;;----------------------------------------------------------- X X(defun fe-get.bndry.vrt () X (car (vput "%" '(("perc" X @ X (@ > @ @) X @) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Virtual Objects X;;=========================================================== X X(defun fe-jam.bndry.vrt.ob (ob) X (vput ob '((~ "perc" X @ X (@ (^ @@) @) X @) **))) X X;;----------------------------------------------------------- X X;; objects are (ob-name (attr-list)) X(defun fe-put.bndry.vrt.ob (ob) X (cond X X ;; assume object is already there X ((car (vput ob `((~ "perc" X @ X (@ (> (,(car ob) @) **) @) X @) **)))) X X ;; object wasn't there, insert new one X ((fe-jam.bndry.vrt.ob ob)) X )) X X;;----------------------------------------------------------- X X;; pass object name X(defun fe-copy.bndry.vrt.ob (ob-name &key (test-time nil)) X (car (vcopy `(("perc" X @ X (@ (> (,ob-name @) **) @) X @) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.bndry.vrt.ob (ob-name) X (car (vget `(("perc" X @ X (@ (> (,ob-name @) **) @) X @) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.bndry.vrt.ob (ob-name) X (car (vput "%" `((~ "perc" X @ X (@ ((~ ,ob-name > @) **) @) X @) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Virtual Object - Complex X;;=========================================================== X X(defun fe-copy.bndry.vrt.ob.names () X (vcopy `(("perc" X @ X (@ ((> @ @) **) @) X @) **) X :freq "all")) X X;;----------------------------------------------------------- X X X X X;;=========================================================== X;; Virtual Object Attributes X;;=========================================================== X X(defun fe-jam.bndry.vrt.ob.attr (ob-name attr) X (cond X ;; assume object exists, add new attr X ((vput attr `((~ "perc" X @ X (@ ((~ ,ob-name (^ @@)) **) @) X @) **))) X X ;; object didn't exist, add new object with new attr. X ((fe-jam.bndry.vrt.ob `(,ob-name (,attr)))) X )) X X;;----------------------------------------------------------- X X(defun fe-put.bndry.vrt.ob.attr (ob-name attr) X (cond X X ;; assume the object and attr exist, swap in new attr X ((car (vput attr `((~ "perc" X @ X (@ ((~ ,ob-name (> (,(car attr) @) **)) **) @) X @) **)))) X X ;; attr didn't exist, add new attr X ((fe-jam.bndry.vrt.ob.attr ob-name attr)) X )) X X;;----------------------------------------------------------- X X(defun fe-xtrct.bndry.vrt.ob.attr (ob-name attr-name) X (car (vget `(("perc" X @ X (@ ((,ob-name (> (,attr-name @) **)) **) @) X @) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.bndry.vrt.ob.attr (ob-name attr-name) X (car (vput "%" `((~ "perc" X @ X (@ ((~ ,ob-name ((~ ,attr-name > @) **)) **) @) X @) **)))) X X;;----------------------------------------------------------- X X;; returns attr struct X(defun fe-copy.bndry.vrt.ob.attr (ob-name attr-name &key (test-time nil)) X (car (vcopy `(("perc" X @ X (@ ((,ob-name (> (,attr-name @) **)) **) @) X @) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Virtual Object Attributes - Complex X;;=========================================================== X X;; returns list of boundary attribute names X(defun fe-copy.bndry.vrt.ob.attr.names (ob-name) X (vcopy `(("perc" X @ X (@ ((,ob-name ((> @ @) **)) **) @) X @) **) X :freq "all")) X X;;----------------------------------------------------------- X X;; returns attr val X(defun fe-copy.bndry.vrt.ob.attr.val (ob-name attr-name) X (car (vcopy `(("perc" X @ X (@ ((,ob-name ((,attr-name > @) **)) **) @) X @) **)))) X X;;----------------------------------------------------------- X X X X X;;=========================================================== X;; Physical Sub-Partition X;;=========================================================== X X;; returns old physical bndry X(defun fe-put.bndry.phys (vbndry) X (car (vput vbndry '((~ "perc" X @ X (@2 > @) X @) **)))) X X;;----------------------------------------------------------- X X(defun fe-copy.bndry.phys (&key (test-time nil)) X (car (vcopy '(("perc" X @ X (@2 > @) X @) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.bndry.phys () X (vget '(("perc" X @ X (@2 (> @@)) X @) **))) X X;;----------------------------------------------------------- X X(defun fe-get.bndry.phys () X (car (vput "%" '((~ "perc" X @ X (@2 > @) X @) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Physical Objects X;;=========================================================== X X(defun fe-jam.bndry.phys.ob (ob) X (vput ob '((~ "perc" X @ X (@2 (^ @@)) X @) **))) X X;;----------------------------------------------------------- X X;; objects are (ob-name (attr-list)) X(defun fe-put.bndry.phys.ob (ob) X (cond X X ;; assume object is already there X ((car (vput ob `((~ "perc" X @ X (@2 (> (,(car ob) @) **)) X @) **)))) X X ;; object wasn't there, insert new one X ((fe-jam.bndry.phys.ob ob)) X )) X X;;----------------------------------------------------------- X X;; pass object name X(defun fe-copy.bndry.phys.ob (ob-name &key (test-time nil)) X (car (vcopy `(("perc" X @ X (@2 (> (,ob-name @) **)) X @) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.bndry.phys.ob (ob-name) X (car (vget `(("perc" X @ X (@2 (> (,ob-name @) **)) X @) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.bndry.phys.ob (ob-name) X (car (vput "%" `((~ "perc" X @ X (@2 ((~ ,ob-name > @) **)) X @) **)))) X X;;----------------------------------------------------------- X X X X X;;=========================================================== X;; Physical Object - Complex X;;=========================================================== X X(defun fe-copy.bndry.phys.ob.names () X (vcopy `(("perc" X @ X (@2 ((> @ @) **)) X @) **) X :freq "all")) X X;;----------------------------------------------------------- X X X X X;;=========================================================== X;; Physical Object Attributes X;;=========================================================== X X(defun fe-jam.bndry.phys.ob.attr (ob-name attr) X (cond X ;; assume object exists, add new attr X ((vput attr `((~ "perc" X @ X (@2 ((~ ,ob-name (^ @@)) **)) X @) **))) X X ;; object didn't exist, add new object with new attr. X ((fe-jam.bndry.phys.ob `(,ob-name (,attr)))) X )) X X;;----------------------------------------------------------- X X(defun fe-put.bndry.phys.ob.attr (ob-name attr) X (cond X X ;; assume the object and attr exist, swap in new attr X ((car (vput attr `((~ "perc" X @ X (@2 ((~ ,ob-name (> (,(car attr) @) **)) **)) X @) **)))) X X ;; attr didn't exist, add new attr X ((fe-jam.bndry.phys.ob.attr ob-name attr)) X )) X X;;----------------------------------------------------------- X X(defun fe-xtrct.bndry.phys.ob.attr (ob-name attr-name) X (car (vget `(("perc" X @ X (@2 ((,ob-name (> (,attr-name @) **)) **)) X @) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.bndry.phys.ob.attr (ob-name attr-name) X (car (vput "%" `((~ "perc" X @ X (@2 ((~ ,ob-name ((~ ,attr-name > @) **)) **)) X @) **)))) X X;;----------------------------------------------------------- X X;; returns attr struct X(defun fe-copy.bndry.phys.ob.attr (ob-name attr-name &key (test-time nil)) X (car (vcopy `(("perc" X @ X (@2 ((,ob-name (> (,attr-name @) **)) **)) X @) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Physical Object Attributes - Complex X;;=========================================================== X X;; returns list of boundary attribute names X(defun fe-copy.bndry.phys.ob.attr.names (ob-name) X (vcopy `(("perc" X @ X (@2 ((,ob-name ((> @ @) **)) **)) X @) **) X :freq "all")) X X;;----------------------------------------------------------- X X;; returns attr val X(defun fe-copy.bndry.phys.ob.attr.val (ob-name attr-name) X (car (vcopy `(("perc" X @ X (@2 ((,ob-name ((,attr-name > @) **)) **)) X @) **)))) X X;;----------------------------------------------------------- X X X X END_OF_FILE if test 10935 -ne `wc -c <'src/kernel_current/fern/fe_bnd.lsp'`; then echo shar: \"'src/kernel_current/fern/fe_bnd.lsp'\" unpacked with wrong size! fi # end of 'src/kernel_current/fern/fe_bnd.lsp' fi if test -f 'src/kernel_current/fern/fe_ext.lsp' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'src/kernel_current/fern/fe_ext.lsp'\" else echo shar: Extracting \"'src/kernel_current/fern/fe_ext.lsp'\" $11360 characters$ sed "s/^X//" >'src/kernel_current/fern/fe_ext.lsp' <<'END_OF_FILE' X;;----------------------------------------------------------- X;; file: fe_ext.lsp X;; X;; FERN is the Fractal Entity Relativity Node. X;; Part of the FE component of the Fern System. X;; X;; creation: March 28, 1992 X;; X;; by Geoffrey P. Coco at the HITLab, Seattle X;;----------------------------------------------------------- X X X;;----------------------------------------------------------- X;; Copyright (C) 1992 Geoffrey P. Coco, X;; Human Interface Technology Lab, Seattle X;;----------------------------------------------------------- X X X;;=========================================================== X;; External X;;=========================================================== X X(defun fe-put.ext (ext) X (vput ext '((~ "perc" X > @ X @ X @) **))) X X;;----------------------------------------------------------- X X(defun fe-copy.ext (&key (test-time nil)) X (car (vcopy '(("perc" X > @ X @ X @) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.ext () X (vget '(("perc" X (> @@) X @ X @) **))) X X;;----------------------------------------------------------- X X(defun fe-get.ext () X (car (vput "%" '((~ "perc" X > @ X @ X @) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Spaces Sub-Partition X;;=========================================================== X X;; returns old space-list X(defun fe-put.ext.sps (sps) X (car (vput sps '((~ "perc" X (> @ @2) X @2) **)))) X X;;----------------------------------------------------------- X X(defun fe-copy.ext.sps (&key (test-time nil)) X (car (vcopy '(("perc" X (> @ @2) X @2) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.ext.sps () X (vget '(("perc" X ((> @@) @2) X @2) **))) X X;;----------------------------------------------------------- X X(defun fe-get.ext.sps () X (car (vput "%" '((~ "perc" X (> @ @2) X @2) **)))) X X;;----------------------------------------------------------- X X X;;=========================================================== X;; Spaces Entities X;;=========================================================== X X;; an ent is (uid data) X(defun fe-jam.ext.sps.ent (ent) X (vput ent '((~ "perc" X ((^ @@) @2) X @2) **))) X X;;----------------------------------------------------------- X X;; an ent is (uid data) X(defun fe-put.ext.sps.ent (ent) X (cond X ;; assume the entity already exists, swap in new one X ((car (vput ent `((~ "perc" X ((> (,(car ent) @) **) @2) X @2) **)))) X X ;; entity didn' exist, insert new ent X ((fe-jam.ext.sps.ent ent)))) X X;;----------------------------------------------------------- X X(defun fe-copy.ext.sps.ent (uid &key (test-time nil)) X (car (vcopy `(("perc" X ((> (,uid @) **) @2) X @2) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.ext.sps.ent (uid) X (car (vget `(("perc" X ((> (,uid @) **) @2) X @2) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.ext.sps.ent (uid) X (car (vput "%" `((~ "perc" X (((~ ,uid > @) **) @2) X @2) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Siblings Sub-Partition X;;=========================================================== X X;; returns old sib-list X(defun fe-put.ext.sibs (sibs) X (car (vput sibs '((~ "perc" X (@ > @ @) X @2) **)))) X X;;----------------------------------------------------------- X X(defun fe-copy.ext.sibs (&key (test-time nil)) X (car (vcopy '(("perc" X (@ > @ @) X @2) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.ext.sibs () X (vget '(("perc" X (@ (> @@) @) X @2) **))) X X;;----------------------------------------------------------- X X(defun fe-get.ext.sibs () X (car (vput "%" '((~ "perc" X (@ > @ @) X @2) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Siblings Entities X;;=========================================================== X X(defun fe-jam.ext.sibs.ent (ent) X (vput ent '((~ "perc" X (@ (^ @@) @) X @2) **))) X X;;----------------------------------------------------------- X X;; sibling entities are in the form: (uid (virtual object list)) X(defun fe-put.ext.sibs.ent (ent) X (cond X ;; assume the ent exists, swap in new ent X ((car (vput ent `((~ "perc" X (@ (> (,(car ent) @) **) @) X @2) **)))) X ;; the ent didn't exist, add new ent X ((fe-jam.ext.sibs.ent ent)) X )) X X;;----------------------------------------------------------- X X(defun fe-copy.ext.sibs.ent (uid &key (test-time nil)) X (car (vcopy `(("perc" X (@ (> (,uid @) **) @) X @2) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.ext.ents.ent (uid) X (car (vget `(("perc" X (@ (> (,uid @) **) @) X @2) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.ext.ents.ent (uid) X (car (vput "%" `((~ "perc" X (@ ((~ ,uid > @) **) @) X @2) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Siblings Entities - Complex X;;=========================================================== X X;; returns list of all external sibs' uids X(defun fe-copy.ext.sibs.uids () X (vcopy '(("perc" X (@ ((> @ @) **) @) X @2) **) X :freq "all")) X X;;----------------------------------------------------------- X X X X X;;=========================================================== X;; Sibling Entities Objects X;;=========================================================== X X(defun fe-jam.ext.sibs.ent.ob (uid ob) X (cond X X ;; assume entity exists, insert new object X ((vput ob `((~ "perc" X (@ ((~ ,uid (^ @@)) **) @) X @2) **))) X X ;; entity wasn't there, insert new entity with new object X ((fe-jam.ext.sibs.ent `(,uid (,ob)))) X )) X X;;----------------------------------------------------------- X X;; ob is a normal object structure: (name (attr-list)) X(defun fe-put.ext.sibs.ent.ob (uid ob) X (cond X X ;; assume entity and object exist, swap in new object X ((car (vput ob `((~ "perc" X (@ ((~ ,uid (> (,(car ob) @) **)) **) @) X @2) **)))) X X ;; object wasn't there, assume entity exists, insert new object X ((fe-jam.ext.sibs.ent.ob uid ob)) X )) X X;;----------------------------------------------------------- X X(defun fe-copy.ext.sibs.ent.ob (uid ob-name &key (test-time nil)) X (car (vcopy `(("perc" X (@ ((,uid (> (,ob-name @) **)) **) @) X @2) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.ext.sibs.ent.ob (uid ob-name) X (car (vget `(("perc" X (@ ((,uid (> (,ob-name @) **)) **) @) X @2) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.ext.sibs.ent.ob (uid ob-name) X (car (vput "%" `((~ "perc" X (@ ((~ ,uid ((~ ,ob-name > @) **)) **) @) X @2) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Sibling Entities Objects - Complex X;;=========================================================== X X;; pass uid, get list of it's ob names X(defun fe-copy.ext.sibs.ent.ob.names (uid) X (vcopy `(("perc" X (@ ((,uid ((> @ @) **)) **) @) X @2) **) X :freq "all")) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Sibling Entities Objects Attributes X;;=========================================================== X X X(defun fe-jam.ext.sibs.ent.ob.attr (uid ob-name attr) X (cond X ;; assume entity and ob exists, insert new attr X ((vput attr `((~ "perc" X (@ X ((~ ,uid ((~ ,ob-name (^ @@)) **)) **) X @) X @2) **))) X X ;; ob wasn't there, insert new ob with new attr X ((fe-jam.ext.sibs.ent.ob uid `(,ob-name (,attr)))) X )) X X;;----------------------------------------------------------- X X;; attr is ("attr-name" attr-val) X(defun fe-put.ext.sibs.ent.ob.attr (uid ob-name attr) X (cond X ;; assume the ent, ob and attr exist, swap in new attr X ((car (vput attr `((~ "perc" X (@ X ((~ ,uid ((~ ,ob-name (> (,(car attr) @) **)) **)) **) X @) X @2) **)))) X X ;; attr wasn't there, insert new attr X ((fe-jam.ext.sibs.ent.ob.attr uid ob-name attr)) X )) X X;;----------------------------------------------------------- X X;; pass uid, ob-num, attr-name X(defun fe-copy.ext.sibs.ent.ob.attr (uid ob-num attr-name &key (test-time nil)) X (car (vcopy `(("perc" X (@ X ((,uid ((,ob-num (> (,attr-name @) **)) **)) **) X @) X @2) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X;; pass uid, ob-num, attr-name X(defun fe-xtrct.ext.sibs.ent.ob.attr (uid ob-num attr-name) X (car (vget `(("perc" X (@ X ((,uid ((,ob-num (> (,attr-name @) **)) **)) **) X @) X @2) **)))) X X;;----------------------------------------------------------- X X;; pass uid, ob-num, attr-name X(defun fe-get.ext.sibs.ent.ob.attr (uid ob-num attr-name) X (car (vput "%" `((~ "perc" X (@ X ((~ ,uid ((~ ,ob-num ((~ ,attr-name > @) **)) **)) **) X @) X @2) **)))) X X;;----------------------------------------------------------- X X X;;=========================================================== X;; Sibling Entities Objects Attributes - Complex X;;=========================================================== X X;; pass uid and ob, return attr-list X(defun fe-copy.ext.sibs.ent.ob.attr.names (uid ob-name) X (vcopy `(("perc" X (@ X ((,uid ((,ob-name ((> @ @) **)) **)) **) X @) X @2) **) X :freq "all")) X X;;----------------------------------------------------------- X X;; pass attr, return values of all objects of all sibs X(defun fe-copy.ext.sibs.attr.vals (attr-name) X (vcopy `(("perc" X (@ X ((@ ((@ ((,attr-name > @) **)) **)) **) X @) X @2) **) X :freq "all")) X X;;----------------------------------------------------------- X X;; pass uid, ob-num, attr-name X(defun fe-copy.ext.sibs.ent.ob.attr.val (uid ob-num attr-name) X (car (vcopy `(("perc" X (@ X ((,uid ((,ob-num ((,attr-name > @) **)) **)) **) X @) X @2) **)))) X X;;----------------------------------------------------------- X X X X X;;=========================================================== X;; Filters Sub-Partition X;;=========================================================== X X;; filters are ("attr" (inclusion-list)) X(defun fe-put.ext.fltrs (fltrs) X (vput fltrs '((~ "perc" X (@2 > @) X @2) **))) X X;;----------------------------------------------------------- X X(defun fe-copy.ext.fltrs (&key (test-time nil)) X (car (vcopy '(("perc" X (@2 > @) X @2) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.ext.fltrs () X (vget '(("perc" X (@2 (> @@)) X @2) **))) X X;;----------------------------------------------------------- X X(defun fe-get.ext.fltrs () X (car (vput "%" '((~ "perc" X (@2 > @) X @2) **)))) X X;;----------------------------------------------------------- END_OF_FILE if test 11360 -ne `wc -c <'src/kernel_current/fern/fe_ext.lsp'`; then echo shar: \"'src/kernel_current/fern/fe_ext.lsp'\" unpacked with wrong size! fi # end of 'src/kernel_current/fern/fe_ext.lsp' fi if test -f 'src/kernel_current/fern/fern.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'src/kernel_current/fern/fern.c'\" else echo shar: Extracting \"'src/kernel_current/fern/fern.c'\" $11012 characters$ sed "s/^X//" >'src/kernel_current/fern/fern.c' <<'END_OF_FILE' X/**************************************************************************************** X * file: fern.c * X * * X * February 25, 1992: implementation of the Fractal Entity Relativity Node for veos. * X * * X * by Geoffrey P. Coco at the HITLab, Seattle. * X * * X ****************************************************************************************/ X X/**************************************************************************************** X * Copyright (C) 1992 Human Interface Technology Lab, Seattle * X ****************************************************************************************/ X X X/*--------------------------------------------------------------------------------* X Preliminaries X *--------------------------------------------------------------------------------*/ X X X#include "xlisp.h" X#include "kernel.h" X#include "xv_native.h" X#include "fern.h" X X#include <math.h> X X/*--------------------------------------------------------------------------------*/ X Xboolean fbase_bInit = FALSE; Xboolean fbase_bGoing = FALSE; XLVAL s_pPersistFunc, s_pPersistProcs; XTStampEntHash fbase_pHashes[5]; Xint fbase_iHashFree; XTXMandRRec fbase_pbCopyIntSubs; XTXMandRRec fbase_pbCopyBndryVrt; X X/*--------------------------------------------------------------------------------*/ X Xvoid Fbase_Frame(); XTVeosErr Fbase_InitMatcherPBs(); X X/*--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------* X Lisp Interface To Fern X *--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ XLVAL Fbase_Init() X{ X if (!fbase_bInit) { X X /** make permanent xlisp symbol to contain persist function call **/ X X s_pPersistFunc = xlenter("FC-PRS-NTRY"); X setvalue(s_pPersistFunc, cons(xlenter("FCON-PERSIST"), NIL)); X X s_pPersistProcs = xlenter("PERSIST-PROCS"); X X fbase_iHashFree = 0; X X Fbase_InitMatcherPBs(); X } X X return(true); X } X/*--------------------------------------------------------------------------------*/ X X X X/*--------------------------------------------------------------------------------*/ XLVAL Fbase_fcon_time() X{ X xllastarg(); X X Fbase_Frame(); X X return(true); X } X/*--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ XLVAL Fbase_fcon_go() X{ X xllastarg(); X X fbase_bGoing = TRUE; X while (fbase_bGoing) X Fbase_Frame(); X X return(true); X } X/*--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ XLVAL Fbase_fcon_local_ungo() X{ X xllastarg(); X X fbase_bGoing = FALSE; X X return(true); X } X/*--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ X/* returns: hash-table-index of new fern maintained hash table X */ XLVAL Fbase_Hash_NewTab() X{ X int i, iHashTab; X X iHashTab = fbase_iHashFree++; X for (i=0; i<12; i++) X fbase_pHashes[iHashTab][i] = nil; X X return(cvfixnum(iHashTab)); X } X/*--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ X/* args: hash-table-refnum, new-uid, initial-float-data X */ XLVAL Fbase_Hash_AddUid() X{ X LVAL pReturn = NIL, pUid; X int i, iHashTab, iHashIndex; X float fData; X TPStampEntRec pNode, pFinger; X X iHashTab = getfixnum(xlgafixnum()); X X pUid = xlgavector(); X#ifndef OPTIMAL X if (!IsUidElt(pUid)) X xlbadtype(pUid); X#endif X X fData = getflonum(xlgaflonum()); X X iHashIndex = FBASE_HASH_HOST(getstring(getelement(pUid, 0))); X X X /** check for this uid already in table... X ** if so, just update data X **/ X for (pNode = fbase_pHashes[iHashTab][iHashIndex]; X pNode; X pNode = pNode->pNext) { X X if (FBASE_HASH_HIT(pUid, pNode)) { X pNode->fData = fData; X pReturn = true; X break; X } X } X X /** uid not found, add new hash entry. X **/ X if (pReturn == NIL) { X X if (Shell_NewBlock(sizeof(TStampEntRec), X &pNode, "fern-hash-node") == VEOS_SUCCESS) { X X strcpy(pNode->sHost, getstring(getelement(pUid, 0))); X pNode->iPort = getfixnum(getelement(pUid, 1)); X pNode->fData = fData; X X pNode->pNext = fbase_pHashes[iHashTab][iHashIndex]; X fbase_pHashes[iHashTab][iHashIndex] = pNode; X X pReturn = true; X } X } X X return(pReturn); X } X/*--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ X/* args: hash-table-index, uid X */ XLVAL Fbase_Hash_RemoveUid() X{ X LVAL pReturn = NIL, pUid; X int i, iHashTab, iHashIndex; X THStampEntRec hFinger; X TPStampEntRec pSave; X X iHashTab = getfixnum(xlgafixnum()); X X pUid = xlgavector(); X if (!IsUidElt(pUid)) X xlbadtype(pUid); X X iHashIndex = FBASE_HASH_HOST(getstring(getelement(pUid, 0))); X for (hFinger = &(fbase_pHashes[iHashTab][iHashIndex]); X *hFinger; X hFinger = &(*hFinger)->pNext) { X X if (FBASE_HASH_HIT(pUid, *hFinger)) { X pSave = *hFinger; X *hFinger = pSave->pNext; X Shell_ReturnBlock(pSave, sizeof(TStampEntRec), "fern-hash-node"); X pReturn = true; X break; X } X } X X return(pReturn); X } X/*--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ X/* args: hash-table-index, uid, float-to-place-data. X * returns: true or NIL X */ XLVAL Fbase_Hash_HashUid() X{ X LVAL pReturn = NIL, pUid, pData; X int i, iHashTab, iHashIndex; X TPStampEntRec pFinger; X X iHashTab = getfixnum(xlgafixnum()); X X pUid = xlgavector(); X if (!IsUidElt(pUid)) X xlbadtype(pUid); X X pData = xlgaflonum(); X X iHashIndex = FBASE_HASH_HOST(getstring(getelement(pUid, 0))); X for (pFinger = fbase_pHashes[iHashTab][iHashIndex]; X pFinger; X pFinger = pFinger->pNext) { X X if (FBASE_HASH_HIT(pUid, pFinger)) { X setflonum(pData, pFinger->fData); X pReturn = true; X break; X } X } X X return(pReturn); X } X/*--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ XLVAL Fbase_Init_CopyIntSubs() X{ X TVeosErr iErr; X X iErr = Native_GetPatternArg(&fbase_pbCopyIntSubs.pPatGr, NANCY_CopyMatch); X X return(iErr == VEOS_SUCCESS ? true : NIL); X } X/*--------------------------------------------------------------------------------*/ X X X X/*--------------------------------------------------------------------------------*/ XLVAL Fbase_CopyIntSubs() X{ X TVeosErr iErr; X LVAL pReturn; X TTimeStamp tTest; X X X /** look for optional time-stamp-test **/ X X NATIVE_TIME_ARG(fbase_pbCopyIntSubs.pTestTime, tTest); X X X /** dispatch the matcher **/ X X xlsave1(fbase_pbCopyIntSubs.pXResult); X X Native_XMandR(&fbase_pbCopyIntSubs); X X xlpop(); X X pReturn = consp(fbase_pbCopyIntSubs.pXResult) ? X car(fbase_pbCopyIntSubs.pXResult) : fbase_pbCopyIntSubs.pXResult; X X return(pReturn); X } X/*--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ XLVAL Fbase_Init_CopyBndryVrt() X{ X TVeosErr iErr; X X iErr = Native_GetPatternArg(&fbase_pbCopyBndryVrt.pPatGr, NANCY_CopyMatch); X X return(iErr == VEOS_SUCCESS ? true : NIL); X } X/*--------------------------------------------------------------------------------*/ X X X X/*--------------------------------------------------------------------------------*/ XLVAL Fbase_CopyBndryVrt() X{ X TVeosErr iErr; X LVAL pReturn; X TTimeStamp tTest; X X X /** look for optional time-stamp-test **/ X X NATIVE_TIME_ARG(fbase_pbCopyBndryVrt.pTestTime, tTest); X X X /** dispatch the matcher **/ X X xlsave1(fbase_pbCopyBndryVrt.pXResult); X X Native_XMandR(&fbase_pbCopyBndryVrt); X X xlpop(); X X pReturn = consp(fbase_pbCopyBndryVrt.pXResult) ? X car(fbase_pbCopyBndryVrt.pXResult) : fbase_pbCopyBndryVrt.pXResult; X X return(pReturn); X } X/*--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------* X Beuratrcatic Linkage Between Fern Prims and XLISP X *--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ XTVeosErr Fern_LoadPrims() X{ X#define FERN_LOAD X#include "fern_prims.h" X#define FERN_LOAD X } X/*--------------------------------------------------------------------------------*/ X X X X/*--------------------------------------------------------------------------------* X Private Functions X *--------------------------------------------------------------------------------*/ X X X/*--------------------------------------------------------------------------------*/ XTVeosErr Fbase_() X{ X TVeosErr iErr; X X return(iErr); X } X/*--------------------------------------------------------------------------------*/ X X X X/*--------------------------------------------------------------------------------*/ Xvoid Fbase_Frame() X{ X LVAL pMsg; X X X /** pass time to veos kernel for accounting. X **/ X Kernel_SystemTask(); X X X for (Native_NextMsg(&pMsg); X pMsg; X Native_NextMsg(&pMsg)) { X X /** invoke normal lisp evaluator on message. X **/ X xlxeval(pMsg); X X /** at top of loop, when msgVar is set to next msg, X ** old contents of msgVar are detached from any protected xlisp ptr, X ** thus it will be garbage collected. X **/ X } X X /** do the persist procs. X **/ X if (!null(getvalue(s_pPersistProcs))) X xleval(getvalue(s_pPersistFunc)); X } X/*--------------------------------------------------------------------------------*/ X X X X/*--------------------------------------------------------------------------------*/ XTVeosErr Fbase_InitMatcherPBs() X{ X /** copy-int-subs settings **/ X X fbase_pbCopyIntSubs.pSrcGr = WORK_SPACE; X fbase_pbCopyIntSubs.iDestroyFlag = NANCY_CopyMatch; X fbase_pbCopyIntSubs.pXReplaceElt = nil; X fbase_pbCopyIntSubs.pStampTime = nil; X X /** copy-bndry-vrt settings **/ X X fbase_pbCopyBndryVrt.pSrcGr = WORK_SPACE; X fbase_pbCopyBndryVrt.iDestroyFlag = NANCY_CopyMatch; X fbase_pbCopyBndryVrt.pXReplaceElt = nil; X fbase_pbCopyBndryVrt.pStampTime = nil; X X return(VEOS_SUCCESS); X X } /* Fbase_InitMatcherPBs */ X/*--------------------------------------------------------------------------------*/ X X X END_OF_FILE if test 11012 -ne `wc -c <'src/kernel_current/fern/fern.c'`; then echo shar: \"'src/kernel_current/fern/fern.c'\" unpacked with wrong size! fi # end of 'src/kernel_current/fern/fern.c' fi if test -f 'src/xlisp/xcore/c/xlimage.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlimage.c'\" else echo shar: Extracting \"'src/xlisp/xcore/c/xlimage.c'\" $11043 characters$ sed "s/^X//" >'src/xlisp/xcore/c/xlimage.c' <<'END_OF_FILE' X/* -*-C-*- X******************************************************************************** X* X* File: xlimage.c X* RCS: $Header: xlimage.c,v 1.5 89/11/25 05:30:58 mayer Exp $ X* Description: xlisp memory image save/restore functions X* Author: David Michael Betz X* Created: X* Modified: Sat Nov 25 05:30:50 1989 (Niels Mayer) mayer@hplnpm X* Language: C X* Package: N/A X* Status: X11r4 contrib tape release X* X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer). X* XLISP version 2.1, Copyright (c) 1989, by David Betz. X* X* Permission to use, copy, modify, distribute, and sell this software and its X* documentation for any purpose is hereby granted without fee, provided that X* the above copyright notice appear in all copies and that both that X* copyright notice and this permission notice appear in supporting X* documentation, and that the name of Hewlett-Packard and David Betz not be X* used in advertising or publicity pertaining to distribution of the software X* without specific, written prior permission. Hewlett-Packard and David Betz X* make no representations about the suitability of this software for any X* purpose. It is provided "as is" without express or implied warranty. X* X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL, X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR X* PERFORMANCE OF THIS SOFTWARE. X* X* See ./winterp/COPYRIGHT for information on contacting the authors. X* X* Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x X* X******************************************************************************** X*/ Xstatic char rcs_identity[] = "@(#)$Header: xlimage.c,v 1.5 89/11/25 05:30:58 mayer Exp $"; X X X#include "xlisp.h" X X#ifdef SAVERESTORE X X/* external variables */ Xextern LVAL obarray,xlenv,xlfenv,xldenv,s_gchook,s_gcflag; Xextern long nnodes,nfree,total; Xextern int anodes,nsegs,gccalls; Xextern struct segment *segs,*lastseg,*fixseg,*charseg; Xextern CONTEXT *xlcontext; Xextern LVAL fnodes; X X/* local variables */ Xstatic OFFTYPE off,foff,doff; Xstatic FILE *fp; X X/* external procedures */ Xextern SEGMENT *newsegment(); Xextern FILE *osbopen(); Xextern char *malloc(); X X/* forward declarations */ XOFFTYPE readptr(); XOFFTYPE cvoptr(); XLVAL cviptr(); X X/* xlisave - save the memory image */ Xint xlisave(fname) X char *fname; X{ X char fullname[STRMAX+1]; X unsigned char *cp; X SEGMENT *seg; X int n,i,max; X LVAL p; X X /* default the extension */ X if (needsextension(fname)) { X strcpy(fullname,fname); X strcat(fullname,".wks"); X fname = fullname; X } X X /* open the output file */ X if ((fp = osbopen(fname,"w")) == NULL) X return (FALSE); X X /* first call the garbage collector to clean up memory */ X gc(); X X /* write out the pointer to the *obarray* symbol */ X writeptr(cvoptr(obarray)); X X /* setup the initial file offsets */ X off = foff = (OFFTYPE)2; X X /* write out all nodes that are still in use */ X for (seg = segs; seg != NULL; seg = seg->sg_next) { X p = &seg->sg_nodes[0]; X for (n = seg->sg_size; --n >= 0; ++p, off += 2) { X switch (ntype(p)) { X case FREE: X break; X case CONS: X case USTREAM: X setoffset(); X osbputc(p->n_type,fp); X writeptr(cvoptr(car(p))); X writeptr(cvoptr(cdr(p))); X foff += 2; X break; X default: X setoffset(); X writenode(p); X break; X } X } X } X X /* write the terminator */ X osbputc(FREE,fp); X writeptr((OFFTYPE)0); X X /* write out data portion of vector-like nodes */ X for (seg = segs; seg != NULL; seg = seg->sg_next) { X p = &seg->sg_nodes[0]; X for (n = seg->sg_size; --n >= 0; ++p) { X switch (ntype(p)) { X/* Include hybrid-class functions: *//* JSP */ X#define MODULE_XLIMAGE_C_XLISAVE X#include "../../xmodules.h" X#undef MODULE_XLIMAGE_C_XLISAVE X X case SYMBOL: X case OBJECT: X case VECTOR: X case CLOSURE: X case STRUCT: X vector: X max = getsz(p); X for (i = 0; i < max; ++i) X writeptr(cvoptr(getelement(p,i))); X break; X case STRING: X max = getslength(p); X for (cp = getstring(p); --max >= 0; ) X osbputc(*cp++,fp); X break; X } X } X } X X /* close the output file */ X osclose(fp); X X /* return successfully */ X return (TRUE); X} X X/* xlirestore - restore a saved memory image */ Xint xlirestore(fname) X char *fname; X{ X extern FUNDEF *funtab; X char fullname[STRMAX+1]; X unsigned char *cp; X int n,i,max,type; X SEGMENT *seg; X LVAL p; X X /* default the extension */ X if (needsextension(fname)) { X strcpy(fullname,fname); X strcat(fullname,".wks"); X fname = fullname; X } X X /* open the file */ X if ((fp = osbopen(fname,"r")) == NULL) X return (FALSE); X X /* free the old memory image */ X freeimage(); X X /* initialize */ X off = (OFFTYPE)2; X total = nnodes = nfree = 0L; X fnodes = NIL; X segs = lastseg = NULL; X nsegs = gccalls = 0; X xlenv = xlfenv = xldenv = s_gchook = s_gcflag = NIL; X xlstack = xlstkbase + EDEPTH; X xlcontext = NULL; X X /* create the fixnum segment */ X if ((fixseg = newsegment(SFIXSIZE)) == NULL) X xlfatal("insufficient memory - fixnum segment"); X X /* create the character segment */ X if ((charseg = newsegment(CHARSIZE)) == NULL) X xlfatal("insufficient memory - character segment"); X X /* read the pointer to the *obarray* symbol */ X obarray = cviptr(readptr()); X X /* read each node */ X while ((type = osbgetc(fp)) >= 0) X switch (type) { X case FREE: X if ((off = readptr()) == (OFFTYPE)0) X goto done; X break; X case CONS: X case USTREAM: X p = cviptr(off); X p->n_type = type; X p->n_flags = 0; X rplaca(p,cviptr(readptr())); X rplacd(p,cviptr(readptr())); X off += 2; X break; X default: X readnode(type,cviptr(off)); X off += 2; X break; X } Xdone: X X /* read the data portion of vector-like nodes */ X for (seg = segs; seg != NULL; seg = seg->sg_next) { X p = &seg->sg_nodes[0]; X for (n = seg->sg_size; --n >= 0; ++p) X switch (ntype(p)) { X/* Include hybrid-class functions: *//* JSP */ X#define MODULE_XLIMAGE_C_XLIRESTORE X#include "../../xmodules.h" X#undef MODULE_XLIMAGE_C_XLIRESTORE X case SYMBOL: X case OBJECT: X case VECTOR: X case CLOSURE: X case STRUCT: X vector: X max = getsz(p); X if ((p->n_vdata = (LVAL *)malloc(max * sizeof(LVAL))) == NULL) X xlfatal("insufficient memory - vector"); X total += (long)(max * sizeof(LVAL)); X for (i = 0; i < max; ++i) X setelement(p,i,cviptr(readptr())); X break; X case STRING: X max = getslength(p); X if ((p->n_string = (unsigned char *)malloc(max)) == NULL) X xlfatal("insufficient memory - string"); X total += (long)max; X for (cp = getstring(p); --max >= 0; ) X *cp++ = osbgetc(fp); X break; X case STREAM: X setfile(p,NULL); X break; X case SUBR: X case FSUBR: X p->n_subr = funtab[getoffset(p)].fd_subr; X break; X } X } X X /* close the input file */ X osclose(fp); X X /* collect to initialize the free space */ X gc(); X X /* lookup all of the symbols the interpreter uses */ X xlsymbols(); X X /* return successfully */ X return (TRUE); X} X X/* freeimage - free the current memory image */ XLOCAL freeimage() X{ X SEGMENT *seg,*next; X FILE *fp; X LVAL p; X int n; X X /* free the data portion of vector-like nodes */ X for (seg = segs; seg != NULL; seg = next) { X p = &seg->sg_nodes[0]; X for (n = seg->sg_size; --n >= 0; ++p) X switch (ntype(p)) { X/* Include hybrid-class functions: *//* JSP */ X#define MODULE_XLIMAGE_C_FREEIMAGE X#include "../../xmodules.h" X#undef MODULE_XLIMAGE_C_FREEIMAGE X case SYMBOL: X case OBJECT: X case VECTOR: X case CLOSURE: X case STRUCT: X vector: X if (p->n_vsize) X free(p->n_vdata); X break; X case STRING: X if (getslength(p)) X free(getstring(p)); X break; X case STREAM: X if ((fp = getfile(p)) && X (fp != stdin && X fp != stdout && X fp != stderr) X ) { X osclose(getfile(p)); X } X break; X } X next = seg->sg_next; X free(seg); X } X} X X/* setoffset - output a positioning command if nodes have been skipped */ XLOCAL setoffset() X{ X if (off != foff) { X osbputc(FREE,fp); X writeptr(off); X foff = off; X } X} X X/* writenode - write a node to a file */ XLOCAL writenode(node) X LVAL node; X{ X char *p = (char *)&node->n_info; X int n = sizeof(union ninfo); X osbputc(node->n_type,fp); X while (--n >= 0) X osbputc(*p++,fp); X foff += 2; X} X X/* writeptr - write a pointer to a file */ XLOCAL writeptr(off) X OFFTYPE off; X{ X char *p = (char *)&off; X int n = sizeof(OFFTYPE); X while (--n >= 0) X osbputc(*p++,fp); X} X X/* readnode - read a node */ XLOCAL readnode(type,node) X int type; LVAL node; X{ X char *p = (char *)&node->n_info; X int n = sizeof(union ninfo); X node->n_type = type; X node->n_flags = 0; X while (--n >= 0) X *p++ = osbgetc(fp); X} X X/* readptr - read a pointer */ XLOCAL OFFTYPE readptr() X{ X OFFTYPE off; X char *p = (char *)&off; X int n = sizeof(OFFTYPE); X while (--n >= 0) X *p++ = osbgetc(fp); X return (off); X} X X/* cviptr - convert a pointer on input */ XLOCAL LVAL cviptr(o) X OFFTYPE o; X{ X OFFTYPE off = (OFFTYPE)2; X SEGMENT *seg; X X /* check for nil */ X if (o == (OFFTYPE)0) X return ((LVAL)o); X X /* compute a pointer for this offset */ X for (seg = segs; seg != NULL; seg = seg->sg_next) { X if (o >= off && o < off + (OFFTYPE)(seg->sg_size << 1)) X return (seg->sg_nodes + ((int)(o - off) >> 1)); X off += (OFFTYPE)(seg->sg_size << 1); X } X X /* create new segments if necessary */ X for (;;) { X X /* create the next segment */ X if ((seg = newsegment(anodes)) == NULL) X xlfatal("insufficient memory - segment"); X X /* check to see if the offset is in this segment */ X if (o >= off && o < off + (OFFTYPE)(seg->sg_size << 1)) X return (seg->sg_nodes + ((int)(o - off) >> 1)); X off += (OFFTYPE)(seg->sg_size << 1); X } X} X X/* cvoptr - convert a pointer on output */ XLOCAL OFFTYPE cvoptr(p) X LVAL p; X{ X OFFTYPE off = (OFFTYPE)2; X SEGMENT *seg; X X /* check for nil and small fixnums */ X if (p == NIL) X return ((OFFTYPE)p); X X /* compute an offset for this pointer */ X for (seg = segs; seg != NULL; seg = seg->sg_next) { X if (CVPTR(p) >= CVPTR(&seg->sg_nodes[0]) && X CVPTR(p) < CVPTR(&seg->sg_nodes[0] + seg->sg_size)) X return (off + (OFFTYPE)((p - seg->sg_nodes) << 1)); X off += (OFFTYPE)(seg->sg_size << 1); X } X X /* pointer not within any segment */ X xlerror("bad pointer found during image save",p); X} X X#endif X END_OF_FILE if test 11043 -ne `wc -c <'src/xlisp/xcore/c/xlimage.c'`; then echo shar: \"'src/xlisp/xcore/c/xlimage.c'\" unpacked with wrong size! fi # end of 'src/xlisp/xcore/c/xlimage.c' fi echo shar: End of archive 5 $of 16$. cp /dev/null ark5isdone MISSING="" for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 ; do if test ! -f ark${I}isdone ; then MISSING="${MISSING} ${I}" fi done if test "${MISSING}" = "" ; then echo You have unpacked all 16 archives. rm -f ark[1-9]isdone ark[1-9][0-9]isdone else echo You still need to unpack the following archives: echo " " ${MISSING} fi ## End of shell archive. exit 0